Developer CD Series 1996 May: Tool Chest/Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso/Tool Chest/Development Tools & Languages/Dylan Related/Thomas/MacGambit⁄Thomas/MacGambit⁄Thomas Sources/Runtime (.scm & .s)/_eval.scm

Text File | 1995-03-15 | 81.0 KB | 2,469 lines | [TEXT/gamI]

(##include "header.scm")

;------------------------------------------------------------------------------

(##define-macro (global-env-loc x) `(##global-var ,x))
(##define-macro (global-env-ref x) `(##global-var-ref ,x))
(##define-macro (global-env-set! x y) `(##global-var-set! ,x ,y))
(##define-macro (global-env-loc->var x) `(##index->global-var-name ,x))

(##define-macro (quasi-list->vector x) `(##quasi-list->vector ,x))
(##define-macro (quasi-append x y) `(##quasi-append ,x ,y))
(##define-macro (quasi-cons x y) `(##quasi-cons ,x ,y))

(##define-macro (true? x) x)
(##define-macro (unbound? x) `(##unbound? ,x))
(##define-macro (unspecified-obj) '##undef-object)
(##define-macro (set!-ret-obj) '##unprint-object)

(define ##self-var     (##string->uninterned-symbol "<self>"))
(define ##selector-var (##string->uninterned-symbol "<selector>"))
(define ##do-loop-var  (##string->uninterned-symbol "<do-loop>"))

(##define-macro (self-var)     '##self-var)
(##define-macro (selector-var) '##selector-var)
(##define-macro (do-loop-var)  '##do-loop-var)

(##define-macro (rt-error-unbound-global-var code rte)
  `(##signal '##SIGNAL.GLOBAL-UNBOUND ,code ,rte))

(##define-macro (rt-error-non-procedure-send code rte)
  `(##signal '##SIGNAL.NON-PROCEDURE-SEND ,code ,rte))

(##define-macro (rt-error-non-procedure-oper code rte)
  `(##signal '##SIGNAL.NON-PROCEDURE-OPERATOR ,code ,rte))

(##define-macro (rt-error-too-few-args proc args)
  `(##signal '##SIGNAL.WRONG-NB-ARG ,proc ,args))

(##define-macro (rt-error-too-many-args proc args)
  `(##signal '##SIGNAL.WRONG-NB-ARG ,proc ,args))

(##define-macro (ct-error-global-env-overflow var)
  `(##signal '##SIGNAL.GLOBAL-ENV-OVERFLOW ,var))

(##define-macro (ct-error-syntax msg . args)
  `(##signal '##SIGNAL.SYNTAX-ERROR src ,msg ,@args))

;------------------------------------------------------------------------------

; Macro to create a node of executable code

(##define-macro (mk-code code-prc subcodes . lst)
  (let ((n (+ (length subcodes) (length lst))))
    `(let (($code (##make-vector ,(+ n 2) #f)))
       (##vector-set! $code 0 #f)
       (##vector-set! $code 1 ,code-prc)
       ,@(let loop1 ((l subcodes) (i 2) (r '()))
           (if (pair? l)
             (loop1 (cdr l)
                    (+ i 1)
                    (cons `(##vector-set! $code ,i (link-to ,(car l) $code)) r))
             (let loop2 ((l lst) (i i) (r r))
               (if (pair? l)
                 (loop2 (cdr l)
                        (+ i 1)
                        (cons `(##vector-set! $code ,i ,(car l)) r))
                 (reverse r)))))
       $code)))

(##define-macro (link-to child parent)
  `(let (($child ,child)) (##vector-set! $child 0 ,parent) $child))

(##define-macro (code-link c)     `(##vector-ref ,c 0))
(##define-macro (code-cprc c)     `(##vector-ref ,c 1))
(##define-macro (code-length c)   `(##fixnum.- (##vector-length ,c) 2))
(##define-macro (code-ref c n)    `(##vector-ref ,c (##fixnum.+ ,n 2)))
(##define-macro (code-set! c n x) `(##vector-set! ,c (##fixnum.+ ,n 2) ,x))
(##define-macro (^ n)             `(##vector-ref $code ,(+ n 2)))

(define (##mk-code* code-prc lst n)
  (let (($code (##make-vector (##fixnum.+ (##length lst) (##fixnum.+ n 2)) #f)))
    (##vector-set! $code 0 #f)
    (##vector-set! $code 1 code-prc)
    (let loop ((i 0) (l lst))
      (if (##pair? l)
        (begin
          (code-set! $code i (link-to (##car l) $code))
          (loop (##fixnum.+ i 1) (##cdr l)))
        $code))))

(##define-macro (code-run c)
  `(let (($$code ,c))
     ((##vector-ref $$code 1) $$code rte)))

; Macro to create the "code procedure" associated with a code node

(##define-macro (mk-cprc . def)
  `(lambda ($code rte) ,@def))

(##define-macro (mk-gen params . def)
  `(lambda (cte src tail? ,@params) ,@def))

(##define-macro (gen proc . args)
  `(,proc cte src tail? ,@args))

;==============================================================================

; Compiler

;------------------------------------------------------------------------------

; Compile time environment manipulation

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Macros to manipulate the compile time environment

(##define-macro (mk-loc-access up over) `(##cons ,up ,over))
(##define-macro (loc-access? x) `(##pair? ,x))
(##define-macro (loc-access-up x) `(##car ,x))
(##define-macro (loc-access-over x) `(##cdr ,x))

(##define-macro (mk-glo-access var)
  `(or (global-env-loc ,var)
       (ct-error-global-env-overflow ,var)))

(##define-macro (glo-access? x)
  `(##not (##pair? ,x)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Initial global environment

(define ##global-env-macros (##cons (##cons #f #f) '()))
(define ##global-env-decls (##cons '() '()))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##make-cte frames)
  (let ((v (##make-vector 3 #f)))
    (##vector-set! v 0 frames)
    (##vector-set! v 1 ##global-env-macros)
    (##vector-set! v 2 ##global-env-decls)
    v))

(define (##cte-frames cte) (##vector-ref cte 0))
(define (##cte-macros cte) (##vector-ref cte 1))
(define (##cte-decls cte)  (##vector-ref cte 2))

(define (##cte-push-frame cte frame)
  (let ((v (##make-vector 3 #f)))
    (##vector-set! v 0 (##cons frame (##cte-frames cte)))
    (##vector-set! v 1 (##cte-macros cte))
    (##vector-set! v 2 (##cte-decls cte))
    v))

(define (##cte-push-macro cte name proc)
  (let ((v (##make-vector 3 #f)))
    (##vector-set! v 0 (##cte-frames cte))
    (##vector-set! v 1 (##cons (##cons name proc) (##cte-macros cte)))
    (##vector-set! v 2 (##cte-decls cte))
    v))

(define (##cte-push-decl cte decl)
  (let ((v (##make-vector 3 #f)))
    (##vector-set! v 0 (##cte-frames cte))
    (##vector-set! v 1 (##cte-macros cte))
    (##vector-set! v 2 (##append decl (##cte-decls cte)))
    v))

(define (##cte-add-global-macro name proc)
  (let ((x (##cdr ##global-env-macros)))
    (let ((y (##assq name x)))
      (if y
        (##set-cdr! y proc)
        (##set-cdr! ##global-env-macros
          (##cons (##cons name proc) (##cdr ##global-env-macros)))))))

(define (##cte-add-global-decl decl)
  (##set-cdr! ##global-env-decls
    (##append decl (##cdr ##global-env-decls))))

(define (##cte-lookup-var cte var)

  (define (lookup e up)
    (if e
      (let ((x (##memq var (##car e))))
        (if x
          (mk-loc-access
            up
            (##fixnum.+ (##fixnum.- (##length (##car e)) (##length x)) 1))
          (lookup (##cdr e) (##fixnum.+ up 1))))
      (mk-glo-access var)))

  (lookup (##cte-frames cte) 0))

(define ##macro? #f)
(set! ##macro?
  (lambda (cte name)
    (and (##symbol? name)
         (##assq name (##cte-macros cte)))))

(set! ##macro-expand #f)
(define ##macro-expand
  (lambda (cte src)
    (let ((x (##car src)))
      (touch-vars (x)
        (##apply (##cdr (##assq x (##cte-macros cte)))
                (##cdr src))))))

;------------------------------------------------------------------------------

; Utilities

(define (##self-eval? val)
  (touch-vars (val)
    (or (##complex? val)
        (##string? val)
        (##char? val)
        (##eq? val #f)
        (##eq? val #t))))

(define (##variable src x)
  (if (##not (##symbol? x))
    (ct-error-syntax "Identifier expected:" x))
  (if (##memq x
              '(QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING LAMBDA IF SET!
                COND => ELSE AND OR CASE LET LET* LETREC BEGIN DO DEFINE
                DELAY FUTURE ##DECLARE ##DEFINE-MACRO ##INCLUDE))
    (ct-error-syntax "Variable name can not be a syntactic keyword:" x)))

(define (##shape src x size)
  (let ((n (##proper-length x)))
    (if (or (##not n)
            (if (##fixnum.< 0 size)
              (##not (##fixnum.= n size))
              (##fixnum.< n (##fixnum.- 0 size))))
      (ct-error-syntax "Ill-formed special form:" (##car src)))))

(define (##proper-length l)

  (define (len l n)
    (cond ((##pair? l) (len (##cdr l) (##fixnum.+ n 1)))
          ((##null? l) n)
          (else        #f)))

  (len l 0))

(define (##touch-list l)
  (if-touches
    (let loop ((l l))
      (touch-vars (l)
        (if (##pair? l)
          (##cons (##car l) (loop (##cdr l)))
          l)))
    l))

(define (##read-expressions cte src filename)
  (if (##string? filename)

    (let ((port (##open-input-file filename)))

      (define (read-exprs)
        (let ((expr (##read port)))
          (if (##not (##eof-object? expr))
            (##cons expr (read-exprs))
            '())))

      (if port
        (let ((exprs (read-exprs)))
          (##close-port port)
          exprs)
        (ct-error-syntax "File not found")))

    (ct-error-syntax "Filename expected")))

;------------------------------------------------------------------------------

; Compiler's main entry

(define (##compile src frames)
  (let ((cte (##make-cte frames)) (tail? #t))
    (gen ##gen-top
      frames
      (##comp-top (##cte-push-frame cte (##list (self-var))) src tail?))))

(define (##comp-top cte src tail?)
  (let ((src (##touch-list src)))
    (cond ((##symbol? src)         (##comp-ref cte src tail?))
          ((##self-eval? src)      (##comp-cst cte src tail?))
          ((##not (##pair? src))   (ct-error-syntax "Ill-formed expression"))
          (else
           (let ((first (##car src)))
             (if (##macro? cte first)
               (##comp-top cte (##macro-expand cte src) tail?)
               (case first
                 ((BEGIN)          (##comp-top-BEGIN cte src tail?))
                 ((DEFINE)         (##comp-top-DEFINE cte src tail?))
                 ((##DECLARE)      (##comp-top-DECLARE cte src tail?))
                 ((##DEFINE-MACRO) (##comp-top-DEFINE-MACRO cte src tail?))
                 ((##INCLUDE)      (##comp-top-INCLUDE cte src tail?))
                 (else             (##comp-aux cte src tail? first)))))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-top-BEGIN cte src tail?)
  (##shape src src -1)
  (##comp-top-seq cte src tail? (##cdr src)))

(define (##comp-top-seq cte src tail? seq)
  (if (##pair? seq)
    (##comp-top-seq-aux cte src tail? seq)
    (gen ##gen-cst (unspecified-obj))))

(define (##comp-top-seq-aux cte src tail? seq)
  (let ((rest (##cdr seq)))
    (if (##pair? rest)
      (gen ##gen-seq
        (##comp-top cte (##car seq) #f)
        (##comp-top-seq-aux cte src tail? rest))
      (##comp-top cte (##car seq) tail?))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-top-DEFINE cte src tail?)
  (let ((cte (##make-cte #f)))
    (let ((name (##definition-name src)))
      (let ((ind (##cte-lookup-var cte name)))
        (gen ##gen-glo-def
          name
          ind
          (##comp cte (##definition-value src) #f))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-top-DECLARE cte src tail?)
  (##shape src src -1)
  (##cte-add-global-decl (##cdr src))
  (gen ##gen-cst (unspecified-obj)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-top-DEFINE-MACRO cte src tail?)
  (let ((name (##definition-name src)))
    (##cte-add-global-macro name (##eval-global (##definition-value src)))
    (gen ##gen-cst name)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-top-INCLUDE cte src tail?)
  (##shape src src 2)
  (##comp-top-seq cte src tail? (##read-expressions cte src (##cadr src))))

;------------------------------------------------------------------------------

(define (##comp cte src tail?)
  (let ((src (##touch-list src)))
    (cond ((##symbol? src)         (##comp-ref cte src tail?))
          ((##self-eval? src)      (##comp-cst cte src tail?))
          ((##not (##pair? src))   (ct-error-syntax "Ill-formed expression"))
          (else
           (let ((first (##car src)))
             (if (##macro? cte first)
               (##comp cte (##macro-expand cte src) tail?)
               (case first
                 ((BEGIN)          (##comp-BEGIN cte src tail?))
                 ((DEFINE)         (ct-error-syntax "Ill-placed 'define'"))
                 ((##DECLARE)      (ct-error-syntax "Ill-placed '##declare'"))
                 ((##DEFINE-MACRO) (ct-error-syntax "Ill-placed '##define-macro'"))
                 ((##INCLUDE)      (ct-error-syntax "Ill-placed '##include'"))
                 (else             (##comp-aux cte src tail? first)))))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-BEGIN cte src tail?)
  (##shape src src -2)
  (##comp-seq cte src tail? (##cdr src)))

(define (##comp-seq cte src tail? seq)
  (if (##pair? seq)
    (##comp-seq-aux cte src tail? seq)
    (gen ##gen-cst (unspecified-obj))))

(define (##comp-seq-aux cte src tail? seq)
  (let ((rest (##cdr seq)))
    (if (##pair? rest)
      (gen ##gen-seq
        (##comp cte (##car seq) #f)
        (##comp-seq-aux cte src tail? rest))
      (##comp cte (##car seq) tail?))))

;------------------------------------------------------------------------------

(define (##comp-aux cte src tail? first)
  (case first
    ((QUOTE)            (##comp-QUOTE cte src tail?))
    ((QUASIQUOTE)       (##comp-QUASIQUOTE cte src tail?))
    ((UNQUOTE)          (ct-error-syntax "Ill-placed 'unquote'"))
    ((UNQUOTE-SPLICING) (ct-error-syntax "Ill-placed 'unquote-splicing'"))
    ((SET!)             (##comp-SET! cte src tail?))
    ((LAMBDA)           (##comp-LAMBDA cte src tail?))
    ((IF)               (##comp-IF cte src tail?))
    ((COND)             (##comp-COND cte src tail?))
    ((AND)              (##comp-AND cte src tail?))
    ((OR)               (##comp-OR cte src tail?))
    ((CASE)             (##comp-CASE cte src tail?))
    ((LET)              (##comp-LET cte src tail?))
    ((LET*)             (##comp-LET* cte src tail?))
    ((LETREC)           (##comp-LETREC cte src tail?))
    ((DO)               (##comp-DO cte src tail?))
    ((DELAY)            (##comp-DELAY cte src tail?))
    ((FUTURE)           (##comp-FUTURE cte src tail?))
    (else               (##comp-app cte src tail?))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-ref cte src tail?)
  (##variable src src)
  (let ((x (##cte-lookup-var cte src)))
    (if (loc-access? x)
      (let ((up (loc-access-up x))
            (over (loc-access-over x)))
        (gen ##gen-loc-ref up over))
      (gen ##gen-glo-ref x))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-cst cte src tail?)
  (gen ##gen-cst src))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-QUOTE cte src tail?)
  (##shape src src 2)
  (gen ##gen-cst (##cadr src)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-QUASIQUOTE cte src tail?)
  (##comp-quasi cte src tail? (##touch-list (##cadr src)) 1))

(define (##comp-quasi cte src tail? form level)
  (cond ((##eq? level 0)
         (##comp cte form tail?))
        ((##pair? form)
         (let ((x (##car form)))
           (touch-vars (x)
             (case x
               ((QUASIQUOTE)
                (##comp-quasi-list cte src tail? form (##fixnum.+ level 1)))
               ((UNQUOTE)
                (if (##eq? level 1)
                  (##comp cte (##cadr form) tail?)
                  (##comp-quasi-list cte src tail? form (##fixnum.- level 1))))
               ((UNQUOTE-SPLICING)
                (if (##eq? level 1)
                  (ct-error-syntax "Ill-placed 'unquote-splicing'"))
                (##comp-quasi-list cte src tail? form (##fixnum.- level 1)))
               (else
                (##comp-quasi-list cte src tail? form level))))))
        ((##vector? form)
         (gen ##gen-quasi-list->vector
           (##comp-quasi-list cte src #f (##vector->list form) level)))
        (else
         (gen ##gen-cst form))))

(define (##comp-quasi-list cte src tail? l level)
  (if (##pair? l)
    (let ((first (##touch-list (##car l))))
      (if (and (##eq? level 1) (##unquote-splicing? first))
        (begin
          (##shape src first 2)
          (if (##null? (##cdr l))
            (##comp cte (##cadr first) tail?)
            (gen ##gen-quasi-append
              (##comp cte (##cadr first) #f)
              (##comp-quasi cte src #f (##cdr l) 1))))
        (gen ##gen-quasi-cons
          (##comp-quasi cte src #f first level)
          (##comp-quasi cte src #f (##cdr l) level))))
    (##comp-quasi cte src tail? l level)))

(define (##unquote-splicing? x)
  (and (##pair? x)
       (let ((y (##car x)))
         (touch-vars (y)
           (##eq? y 'UNQUOTE-SPLICING)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-SET! cte src tail?)
  (##shape src src 3)
  (let ((var (##cadr src)))
    (touch-vars (var)
      (begin
        (##variable src var)
        (let ((x (##cte-lookup-var cte var)))
          (if (loc-access? x)
            (let ((up (loc-access-up x))
                  (over (loc-access-over x)))
              (gen ##gen-loc-set up over (##comp cte (##caddr src) #f)))
            (gen ##gen-glo-set x (##comp cte (##caddr src) #f))))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-LAMBDA cte src tail?)
  (##shape src src -3)
  (##comp-lambda-aux cte src tail? (##touch-list (##cadr src)) (##cddr src)))

(define (##comp-lambda-aux cte src tail? parms body)
  (let ((frame (##parms->frame src parms)))
    (let ((c (##comp-body (##cte-push-frame cte (##cons (self-var) frame)) src #t body)))
      (if (##rest-param? parms)
        (gen ##gen-prc-rest frame c)
        (gen ##gen-prc frame c)))))

(define (##parms->frame src parms)
  (cond ((##null? parms)
         '())
        ((##pair? parms)
         (let ((x (##car parms)))
           (touch-vars (x)
             (let ((rest (##parms->frame src (##cdr parms))))
               (##variable src x)
               (if (##memq x rest)
                 (ct-error-syntax "Duplicate parameter in parameter list"))
               (##cons x rest)))))
        (else
         (##variable src parms)
         (##list parms))))

(define (##rest-param? parms)
  (cond ((##pair? parms)
         (##rest-param? (##cdr parms)))
        ((##null? parms)
         #f)
        (else
         #t)))

(define (##comp-body cte src tail? body)

  (define (letrec-defines cte vars vals body)
    (if (##pair? body)

      (let ((src (##touch-list (##car body))))
        (if (##not (##pair? src))
          (letrec-defines* cte vars vals body)
          (let ((first (##car src)))
            (touch-vars (first)
              (if (##macro? cte first)
                (letrec-defines cte
                                vars
                                vals
                                (##cons (##macro-expand cte src) (##cdr body)))
                (case first
                  ((BEGIN)
                   (letrec-defines cte
                                   vars
                                   vals
                                   (##append (##cdr src) (##cdr body))))
                  ((DEFINE)
                   (let ((x (##definition-name src)))
                     (##variable src x)
                     (if (##memq x vars)
                       (ct-error-syntax "Duplicate definition of a variable"))
                     (letrec-defines cte
                                     (##cons x vars)
                                     (##cons (##definition-value src) vals)
                                     (##cdr body))))
                  ((##DECLARE)
                   (##shape src src -1)
                   (letrec-defines (##cte-push-decl cte (##cdr src))
                                   vars
                                   vals
                                   (##cdr body)))
                  ((##DEFINE-MACRO)
                   (let ((x (##definition-name src)))
                     (letrec-defines (##cte-push-macro
                                       cte
                                       x
                                       (##eval-global (##definition-value src)))
                                     vars
                                     vals
                                     (##cdr body))))
                  ((##INCLUDE)
                   (##shape src src 2)
                   (letrec-defines cte
                                   vars
                                   vals
                                   (##append (##read-expressions cte src (##cadr src))
                                             (##cdr body))))
                  (else
                   (letrec-defines* cte vars vals body))))))))

      (ct-error-syntax "Body must contain at least one evaluable expression")))

  (define (letrec-defines* cte vars vals body)
    (if (##null? vars)
      (##comp-seq cte src tail? body)
      (##comp-letrec-aux cte src tail? vars vals body)))

  (letrec-defines cte '() '() body))

(define (##definition-name src)
  (##shape src src -3)
  (let ((pattern (##cadr src)))
    (touch-vars (pattern)
      (let ((name (if (##pair? pattern)
                    (let ((name (##car pattern)))
                      (touch-vars (name)
                        name))
                    (begin
                      (##shape src src 3)
                      pattern))))
        (if (##not (##symbol? name))
          (ct-error-syntax "Defined variable must be an identifier"))
        name))))

(define (##definition-value src)
  (let ((pattern (##cadr src)))
    (touch-vars (pattern)
      (if (##pair? pattern)
        (##cons 'LAMBDA (##cons (##cdr pattern) (##cddr src)))
        (##caddr src)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-IF cte src tail?)
  (##shape src src -3)
  (if (##pair? (##cdddr src))
    (begin
      (##shape src src 4)
      (gen ##gen-if3
        (##comp cte (##cadr src) #f)
        (##comp cte (##caddr src) tail?)
        (##comp cte (##cadddr src) tail?)))
    (begin
      (##shape src src 3)
      (gen ##gen-if2
        (##comp cte (##cadr src) #f)
        (##comp cte (##caddr src) tail?)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-COND cte src tail?)
  (##shape src src -2)
  (##comp-cond-aux cte src tail? (##cdr src)))

(define (##comp-cond-aux cte src tail? clauses)
  (if (##pair? clauses)
    (let ((clause (##touch-list (##car clauses))))
      (##shape src clause -1)
      (let ((x (##car clause)))
        (touch-vars (x)
          (cond ((##eq? x 'ELSE)
                 (##shape src clause -2)
                 (if (##not (##null? (##cdr clauses)))
                   (ct-error-syntax "ELSE clause must be last"))
                 (##comp-seq cte src tail? (##cdr clause)))
                ((##not (##pair? (##cdr clause)))
                 (gen ##gen-cond-or
                    (##comp cte (##car clause) #f)
                    (##comp-cond-aux cte src tail? (##cdr clauses))))
                (else
                 (let ((y (##cadr clause)))
                   (touch-vars (y)
                     (if (##eq? y '=>)
                       (begin
                         (##shape src clause -3)
                         (gen ##gen-cond-send
                           (##comp cte (##car clause) #f)
                           (##comp cte (##caddr clause) #f)
                           (##comp-cond-aux cte src tail? (##cdr clauses))))
                       (gen ##gen-cond-if
                         (##comp cte (##car clause) #f)
                         (##comp-seq cte src tail? (##cdr clause))
                         (##comp-cond-aux cte src tail? (##cdr clauses)))))))))))
    (gen ##gen-cst (unspecified-obj))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-AND cte src tail?)
  (let ((rest (##cdr src)))
    (if (##pair? rest)
      (##comp-and-aux cte src tail? rest)
      (gen ##gen-cst #t))))

(define (##comp-and-aux cte src tail? l)
  (let ((rest (##cdr l)))
    (if (##pair? rest)
      (gen ##gen-and
        (##comp cte (##car l) #f)
        (##comp-and-aux cte src tail? rest))
      (##comp cte (##car l) tail?))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-OR cte src tail?)
  (let ((rest (##cdr src)))
    (if (##pair? rest)
      (##comp-or-aux cte src tail? rest)
      (gen ##gen-cst #f))))

(define (##comp-or-aux cte src tail? l)
  (let ((rest (##cdr l)))
    (if (##pair? rest)
      (gen ##gen-or
        (##comp cte (##car l) #f)
        (##comp-or-aux cte src tail? rest))
      (##comp cte (##car l) tail?))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-CASE cte src tail?)
  (##shape src src -3)
  (gen ##gen-case
    (##comp cte (##cadr src) #f)
    (let ((cte (##cte-push-frame cte (##list (selector-var)))))
      (##comp-case-aux cte src tail? (##cddr src)))))

(define (##comp-case-aux cte src tail? clauses)
  (if (##pair? clauses)
    (let ((clause (##touch-list (##car clauses))))
      (##shape src clause -2)
      (let ((first (##touch-list (##car clause))))
        (if (##eq? first 'ELSE)
          (begin
            (if (##not (##null? (##cdr clauses)))
              (ct-error-syntax "ELSE clause must be last"))
            (gen ##gen-case-else
              (##comp-seq cte src tail? (##cdr clause))))
          (gen ##gen-case-clause
            first
            (##comp-seq cte src tail? (##cdr clause))
            (##comp-case-aux cte src tail? (##cdr clauses))))))
    (gen ##gen-case-else
      (gen ##gen-cst (unspecified-obj)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-LET cte src tail?)
  (##shape src src -3)
  (let ((x (##touch-list (##cadr src))))
    (cond ((##symbol? x)
           (##shape src src -4)
           (let ((bindings (##touch-list (##caddr src))))
             (let* ((vars (##bindings->vars src bindings #t))
                    (vals (##bindings->vals bindings)))
               (gen ##gen-app
                 (let ((inner-cte (##cte-push-frame cte (##list x))))
                   (gen ##gen-letrec
                     (##list x)
                     (let ((cte inner-cte)
                           (tail? #f))
                       (##list (gen ##gen-prc
                               vars
                               (##comp-body (##cte-push-frame cte (##cons (self-var) vars))
                                            src
                                            #t
                                            (##cdddr src)))))
                     (let ((cte inner-cte)
                           (tail? #f))
                       (gen ##gen-loc-ref 0 1)))) ; fetch loop variable
                 (##comp-vals cte vals)))))
          ((##null? x)
           (##comp-body cte src tail? (##cddr src)))
          (else
           (let* ((bindings x)
                  (vars (##bindings->vars src bindings #t))
                  (vals (##bindings->vals bindings)))
             (let ((c (##comp-body (##cte-push-frame cte vars) src tail? (##cddr src))))
               (gen ##gen-let
                 vars
                 (##comp-vals cte vals)
                 c)))))))

(define (##comp-vals cte l)
  (if (##pair? l)
    (##cons (##comp cte (##car l) #f) (##comp-vals cte (##cdr l)))
    '()))

(define (##bindings->vars src bindings check-duplicates?)
  (if (##pair? bindings)
    (let ((binding (##touch-list (##car bindings))))
      (##shape src binding 2)
      (let ((x (##car binding)))
        (touch-vars (x)
          (let ((rest (##bindings->vars src (##cdr bindings) check-duplicates?)))
            (##variable src x)
            (if (and check-duplicates? (##memq x rest))
              (ct-error-syntax "Duplicate variable in bindings"))
            (##cons x rest)))))
    (if (##null? bindings)
      '()
      (ct-error-syntax "Ill-terminated bindings"))))

(define (##bindings->vals bindings)
  (if (##pair? bindings)
    (let ((binding (##touch-list (##car bindings))))
      (##cons (##cadr binding) (##bindings->vals (##cdr bindings))))
    '()))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-LET* cte src tail?)
  (##shape src src -3)
  (let ((bindings (##cadr src)))
    (touch-vars (bindings)
      (let* ((vars (##bindings->vars src bindings #f))
             (vals (##bindings->vals bindings)))
        (##comp-let*-aux cte src tail? vars vals (##cddr src))))))

(define (##comp-let*-aux cte src tail? vars vals body)
  (if (##pair? vars)
    (let ((frame (##list (##car vars))))
      (let ((inner-cte (##cte-push-frame cte frame)))
        (gen ##gen-let
          frame
          (##list (##comp cte (##car vals) #f))
          (##comp-let*-aux inner-cte src tail? (##cdr vars) (##cdr vals) body))))
    (##comp-body cte src tail? body)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-LETREC cte src tail?)
  (##shape src src -3)
  (let ((bindings (##touch-list (##cadr src))))
    (if (##null? bindings)
      (##comp-body cte src tail? (##cddr src))
      (let* ((vars (##bindings->vars src bindings #t))
             (vals (##bindings->vals bindings)))
        (##comp-letrec-aux cte src tail? vars vals (##cddr src))))))

(define (##comp-letrec-aux cte src tail? vars vals body)
  (if (##pair? vars)
    (let ((inner-cte (##cte-push-frame cte vars)))
      (gen ##gen-letrec
        vars
        (##comp-vals inner-cte vals)
        (##comp-body inner-cte src tail? body)))
    (##comp-body cte src tail? body)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-do cte src tail?)
  (##shape src src -3)
  (let ((bindings (##touch-list (##cadr src)))
        (exit (##touch-list (##caddr src))))
    (##shape src exit -1)
    (let* ((vars (##bindings->vars* src bindings))
           (do-loop-vars (##list (do-loop-var)))
           (inner-cte (##cte-push-frame cte do-loop-vars)))
      (gen ##gen-letrec
        do-loop-vars
        (##list
          (let ((cte inner-cte)
                (tail? #f))
            (gen ##gen-prc
              vars
              (let ((cte (##cte-push-frame cte (##cons (self-var) vars)))
                    (tail? #t))
                (gen ##gen-if3
                  (##comp cte (##car exit) #f)
                  (##comp-seq cte src tail? (##cdr exit))
                  (let ((call
                          (gen ##gen-app
                            (let ((tail? #f))
                              (gen ##gen-loc-ref 1 1)) ; fetch do-loop-var
                            (##comp-vals cte (##bindings->steps bindings)))))
                    (if (##null? (##cdddr src))
                      call
                      (gen ##gen-seq
                        (##comp-seq cte src #f (##cdddr src))
                        call))))))))
        (let ((cte inner-cte))
          (gen ##gen-app
            (let ((tail? #f))
              (gen ##gen-loc-ref 0 1)) ; fetch do-loop-var
            (##comp-vals cte (##bindings->vals bindings))))))))

(define (##bindings->vars* src bindings)
  (if (##pair? bindings)
    (let ((binding (##touch-list (##car bindings))))
      (##shape src binding -2)
      (if (##pair? (##cddr binding)) (##shape src binding 3))
      (let ((x (##car binding)))
        (touch-vars (x)
          (let ((rest (##bindings->vars* src (##cdr bindings))))
            (##variable src x)
            (if (##memq x rest)
              (ct-error-syntax "Duplicate variable in bindings"))
            (##cons x rest)))))
    (if (##null? bindings)
      '()
      (ct-error-syntax "Ill-terminated bindings"))))

(define (##bindings->steps bindings)
  (if (##pair? bindings)
    (let ((binding (##touch-list (##car bindings))))
      (##cons (if (##pair? (##cddr binding)) (##caddr binding) (##car binding))
              (##bindings->steps (##cdr bindings))))
    '()))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-app cte src tail?)
  (let ((n (##proper-length src)))
    (if n
      (gen ##gen-app
        (##comp cte (##car src) #f)
        (##comp-vals cte (##cdr src)))
      (ct-error-syntax "Ill-formed procedure application"))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-DELAY cte src tail?)
  (##shape src src 2)
  (gen ##gen-delay (##comp cte (##cadr src) #t)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##comp-FUTURE cte src tail?)
  (##shape src src 2)
  (gen ##gen-future (##comp cte (##cadr src) #t)))

;==============================================================================

; Code generation procedures

;------------------------------------------------------------------------------

; Macros to manipulate the runtime environment

(##define-macro (mk-rte rte . lst)
  (let ((n (length lst)))
    `(let (($rte (##make-vector ,(+ n 1) (unspecified-obj))))
       (##vector-set! $rte 0 ,rte)
       ,@(let loop2 ((l lst) (i 1) (r '()))
           (if (pair? l)
             (loop2 (cdr l) (+ i 1) (cons `(##vector-set! $rte ,i ,(car l)) r))
             (reverse r)))
       $rte)))

(##define-macro (mk-rte* rte n)
  `(let (($rte (##make-vector (##fixnum.+ ,n 1) (unspecified-obj))))
     (##vector-set! $rte 0 ,rte)
     $rte))

(##define-macro (rte-up rte)         `(##vector-ref ,rte 0))
(##define-macro (rte-ref rte i)      `(##vector-ref ,rte ,i))
(##define-macro (rte-set! rte i val) `(##vector-set! ,rte ,i ,val))

;------------------------------------------------------------------------------

(define ##cprc-top
  (mk-cprc
    (##subproblem-apply0 $code rte
      (lambda ()
        (let ((rte (mk-rte rte #f)))
          (code-run (^ 0)))))))

(define ##gen-top
  (mk-gen (frames val)
    (mk-code ##cprc-top (val) frames)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-cst-null  (mk-cprc '()))
(define ##cprc-cst-true  (mk-cprc #t))
(define ##cprc-cst-false (mk-cprc #f))
(define ##cprc-cst--2    (mk-cprc -2))
(define ##cprc-cst--1    (mk-cprc -1))
(define ##cprc-cst-0     (mk-cprc 0))
(define ##cprc-cst-1     (mk-cprc 1))
(define ##cprc-cst-2     (mk-cprc 2))
(define ##cprc-cst       (mk-cprc (^ 0)))

(define ##gen-cst
  (mk-gen (val)
    (case val
      ((()) (mk-code ##cprc-cst-null  ()))
      ((#t) (mk-code ##cprc-cst-true  ()))
      ((#f) (mk-code ##cprc-cst-false ()))
      ((-2) (mk-code ##cprc-cst--2    ()))
      ((-1) (mk-code ##cprc-cst--1    ()))
      ((0)  (mk-code ##cprc-cst-0     ()))
      ((1)  (mk-code ##cprc-cst-1     ()))
      ((2)  (mk-code ##cprc-cst-2     ()))
      (else (mk-code ##cprc-cst       () val)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-loc-ref-0-1 (mk-cprc (rte-ref rte 1)))
(define ##cprc-loc-ref-0-2 (mk-cprc (rte-ref rte 2)))
(define ##cprc-loc-ref-0-3 (mk-cprc (rte-ref rte 3)))

(define ##cprc-loc-ref-1-1 (mk-cprc (rte-ref (rte-up rte) 1)))
(define ##cprc-loc-ref-1-2 (mk-cprc (rte-ref (rte-up rte) 2)))
(define ##cprc-loc-ref-1-3 (mk-cprc (rte-ref (rte-up rte) 3)))

(define ##cprc-loc-ref-2-1 (mk-cprc (rte-ref (rte-up (rte-up rte)) 1)))
(define ##cprc-loc-ref-2-2 (mk-cprc (rte-ref (rte-up (rte-up rte)) 2)))
(define ##cprc-loc-ref-2-3 (mk-cprc (rte-ref (rte-up (rte-up rte)) 3)))

(define ##cprc-loc-ref
  (mk-cprc
    (let loop ((e rte) (i (^ 0)))
      (if (##fixnum.< 0 i)
        (loop (rte-up e) (##fixnum.- i 1))
        (rte-ref e (^ 1))))))

(define ##gen-loc-ref
  (mk-gen (up over)
    (case up
      ((0)
       (case over
         ((1)  (mk-code ##cprc-loc-ref-0-1 ()))
         ((2)  (mk-code ##cprc-loc-ref-0-2 ()))
         ((3)  (mk-code ##cprc-loc-ref-0-3 ()))
         (else (mk-code ##cprc-loc-ref     () up over))))
      ((1)
       (case over
         ((1)  (mk-code ##cprc-loc-ref-1-1 ()))
         ((2)  (mk-code ##cprc-loc-ref-1-2 ()))
         ((3)  (mk-code ##cprc-loc-ref-1-3 ()))
         (else (mk-code ##cprc-loc-ref     () up over))))
      ((2)
       (case over
         ((1)  (mk-code ##cprc-loc-ref-2-1 ()))
         ((2)  (mk-code ##cprc-loc-ref-2-2 ()))
         ((3)  (mk-code ##cprc-loc-ref-2-3 ()))
         (else (mk-code ##cprc-loc-ref     () up over))))
     (else
       (mk-code ##cprc-loc-ref () up over)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-glo-ref
  (mk-cprc
    (let loop ((val (global-env-ref (^ 0))))
      (if (unbound? val)
        (loop (rt-error-unbound-global-var $code rte))
        val))))

(define ##gen-glo-ref
  (mk-gen (ind)
    (mk-code ##cprc-glo-ref () ind)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-loc-set
  (mk-cprc
    (let ((val (code-run (^ 0))))
      (let loop ((e rte) (i (^ 1)))
        (if (##fixnum.< 0 i)
          (loop (rte-up e) (##fixnum.- i 1))
          (begin
            (rte-set! e (^ 2) val)
            (set!-ret-obj)))))))

(define ##gen-loc-set
  (mk-gen (up over val)
    (mk-code ##cprc-loc-set (val) up over)))

(define ##cprc-glo-set
  (mk-cprc
    (let ((val (code-run (^ 0))))
      (global-env-set! (^ 1) val)
      (set!-ret-obj))))

(define ##gen-glo-set
  (mk-gen (ind val)
    (mk-code ##cprc-glo-set (val) ind)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-glo-def
  (mk-cprc
    (let ((rte #f))
      (global-env-set! (^ 1) (code-run (^ 0)))
      (^ 2))))

(define ##gen-glo-def
  (mk-gen (name ind val)
    (mk-code ##cprc-glo-def (val) ind name)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-if2
  (mk-cprc
    (let ((pred (code-run (^ 0))))
      (touch-vars (pred)
        (if (true? pred)
          (code-run (^ 1))
          (unspecified-obj))))))

(define ##gen-if2
  (mk-gen (pre con)
    (mk-code ##cprc-if2 (pre con))))

(define ##cprc-if3
  (mk-cprc
    (let ((pred (code-run (^ 0))))
      (touch-vars (pred)
        (if (true? pred)
          (code-run (^ 1))
          (code-run (^ 2)))))))

(define ##gen-if3
  (mk-gen (pre con alt)
    (mk-code ##cprc-if3 (pre con alt))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-seq
  (mk-cprc
    (code-run (^ 0))
    (code-run (^ 1))))

(define ##gen-seq
  (mk-gen (val1 val2)
    (mk-code ##cprc-seq (val1 val2))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-quasi-list->vector
  (mk-cprc
    (quasi-list->vector (code-run (^ 0)))))

(define ##gen-quasi-list->vector
  (mk-gen (val)
    (mk-code ##cprc-quasi-list->vector (val))))

(define ##cprc-quasi-append
  (mk-cprc
    (quasi-append (code-run (^ 0)) (code-run (^ 1)))))

(define ##gen-quasi-append
  (mk-gen (val1 val2)
    (mk-code ##cprc-quasi-append (val1 val2))))

(define ##cprc-quasi-cons
  (mk-cprc
    (quasi-cons (code-run (^ 0)) (code-run (^ 1)))))

(define ##gen-quasi-cons
  (mk-gen (val1 val2)
    (mk-code ##cprc-quasi-cons (val1 val2))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-cond-if
  (mk-cprc
    (let ((pred (code-run (^ 0))))
      (touch-vars (pred)
        (if (true? pred)
          (code-run (^ 1))
          (code-run (^ 2)))))))

(define ##gen-cond-if
  (mk-gen (val1 val2 val3)
    (mk-code ##cprc-cond-if (val1 val2 val3))))

(define ##cprc-cond-or
  (mk-cprc
    (let ((pred (code-run (^ 0))))
      (touch-vars (pred)
        (if (true? pred)
          pred
          (code-run (^ 1)))))))

(define ##gen-cond-or
  (mk-gen (val1 val2)
    (mk-code ##cprc-cond-or (val1 val2))))

(define ##cprc-cond-send-red
  (mk-cprc
    (let ((pred (code-run (^ 0))))
      (touch-vars (pred)
        (if (true? pred)
          (let loop ((proc (code-run (^ 1))))
            (touch-vars (proc)
              (if (##not (##procedure? proc))
                (loop (rt-error-non-procedure-send $code rte))
                (##reduction-apply1 $code rte proc pred))))
          (code-run (^ 2)))))))

(define ##cprc-cond-send-sub
  (mk-cprc
    (let ((pred (code-run (^ 0))))
      (touch-vars (pred)
        (if (true? pred)
          (let loop ((proc (code-run (^ 1))))
            (touch-vars (proc)
              (if (##not (##procedure? proc))
                (loop (rt-error-non-procedure-send $code rte))
                (##subproblem-apply1 $code rte proc pred))))
          (code-run (^ 2)))))))

(define ##gen-cond-send
  (mk-gen (val1 val2 val3)
    (mk-code (if tail? ##cprc-cond-send-red ##cprc-cond-send-sub)
             (val1 val2 val3))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-or
  (mk-cprc
    (let ((pred (code-run (^ 0))))
      (touch-vars (pred)
        (if (true? pred)
          pred
          (code-run (^ 1)))))))

(define ##gen-or
  (mk-gen (val1 val2)
    (mk-code ##cprc-or (val1 val2))))

(define ##cprc-and
  (mk-cprc
    (let ((pred (code-run (^ 0))))
      (touch-vars (pred)
        (if (##not (true? pred))
          pred
          (code-run (^ 1)))))))

(define ##gen-and
  (mk-gen (val1 val2)
    (mk-code ##cprc-and (val1 val2))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-case
  (mk-cprc
    (let ((selector (code-run (^ 0))))
      (touch-vars (selector)
        (let ((rte (mk-rte rte selector)))
          (code-run (^ 1)))))))

(define ##gen-case
  (mk-gen (val1 val2)
    (mk-code ##cprc-case (val1 val2))))

(define ##cprc-case-clause
  (mk-cprc
    (if (##case-memv (rte-ref rte 1) (^ 2))
      (code-run (^ 0))
      (code-run (^ 1)))))

(define ##gen-case-clause
  (mk-gen (cases val1 val2)
    (mk-code ##cprc-case-clause (val1 val2) cases)))

(define ##cprc-case-else
  (mk-cprc
    (code-run (^ 0))))

(define ##gen-case-else
  (mk-gen (val)
    (mk-code ##cprc-case-else (val))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-let
  (mk-cprc
    (let ((n (##fixnum.- (code-length $code) 2)))
      (let ((inner-rte (mk-rte* rte n)))
        (let loop ((i n))
          (if (##fixnum.< 0 i)
            (begin
              (rte-set! inner-rte i (code-run (code-ref $code i)))
              (loop (##fixnum.- i 1)))
            (let ((rte inner-rte))
              (code-run (^ 0)))))))))

(define ##gen-let
  (mk-gen (vars vals body)
    (let ((c (##mk-code* ##cprc-let (##cons body vals) 1)))
      (code-set! c (##fixnum.+ (##length vals) 1) vars)
      c)))

(define ##cprc-letrec
  (mk-cprc
    (let ((n (##fixnum.- (code-length $code) 2)))
      (let ((rte (mk-rte* rte n)))
        (let loop ((i n))
          (if (##fixnum.< 0 i)
            (begin
              (rte-set! rte i (code-run (code-ref $code i)))
              (loop (##fixnum.- i 1)))
            (code-run (^ 0))))))))

(define ##gen-letrec
  (mk-gen (vars vals body)
    (let ((c (##mk-code* ##cprc-letrec (##cons body vals) 1)))
      (code-set! c (##fixnum.+ (##length vals) 1) vars)
      c)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-prc0
  (mk-cprc
    (letrec ((proc
               (lambda ()
                 (let ((rte (mk-rte rte proc)))
                   (code-run (^ 0))))))
      proc)))

(define ##cprc-prc1
  (mk-cprc
    (letrec ((proc
               (lambda (arg1)
                 (let ((rte (mk-rte rte proc arg1)))
                   (code-run (^ 0))))))
      proc)))

(define ##cprc-prc2
  (mk-cprc
    (letrec ((proc
               (lambda (arg1 arg2)
                 (let ((rte (mk-rte rte proc arg1 arg2)))
                   (code-run (^ 0))))))
      proc)))

(define ##cprc-prc3
  (mk-cprc
    (letrec ((proc
               (lambda (arg1 arg2 arg3)
                 (let ((rte (mk-rte rte proc arg1 arg2 arg3)))
                   (code-run (^ 0))))))
      proc)))

(define ##cprc-prc
  (mk-cprc
    (letrec ((proc
               (lambda args
                 (let ((n (^ 1)))
                   (let ((inner-rte (mk-rte* rte n)))
                     (rte-set! inner-rte 1 proc)
                     (let loop ((i 2) (l args))
                       (if (##fixnum.< n i)
                         (if (##pair? l)
                           (rt-error-too-many-args proc args)
                           (let ((rte inner-rte))
                             (code-run (^ 0))))
                         (if (##pair? l)
                           (begin
                             (rte-set! inner-rte i (##car l))
                             (loop (##fixnum.+ i 1) (##cdr l)))
                           (rt-error-too-few-args proc args)))))))))
      proc)))

(define ##gen-prc
  (mk-gen (frame body)
    (case (##length frame)
      ((0)  (mk-code ##cprc-prc0 (body) frame))
      ((1)  (mk-code ##cprc-prc1 (body) frame))
      ((2)  (mk-code ##cprc-prc2 (body) frame))
      ((3)  (mk-code ##cprc-prc3 (body) frame))
      (else (mk-code ##cprc-prc  (body) (##fixnum.+ (##length frame) 1) frame)))))

(define ##cprc-prc-rest
  (mk-cprc
    (letrec ((proc
               (lambda args
                 (let ((n (^ 1)))
                   (let ((inner-rte (mk-rte* rte n)))
                     (rte-set! inner-rte 1 proc)
                     (let loop ((i 2) (l args))
                       (if (##fixnum.< i n)
                         (if (##pair? l)
                           (begin
                             (rte-set! inner-rte i (##car l))
                             (loop (##fixnum.+ i 1) (##cdr l)))
                           (rt-error-too-few-args proc args))
                         (begin
                           (rte-set! inner-rte i l)
                           (let ((rte inner-rte))
                             (code-run (^ 0)))))))))))
      proc)))

(define ##gen-prc-rest
  (mk-gen (frame body)
    (mk-code ##cprc-prc-rest (body) (##fixnum.+ (##length frame) 1) frame)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-app0-red
  (mk-cprc
    (let ((proc (code-run (^ 0))))
      (touch-vars (proc)
        (if (##not (##procedure? proc))
          (rt-error-non-procedure-oper $code rte)
          (##reduction-apply0 $code rte proc))))))

(define ##cprc-app1-red
  (mk-cprc
    (let ((proc (code-run (^ 0))))
      (touch-vars (proc)
        (if (##not (##procedure? proc))
          (rt-error-non-procedure-oper $code rte)
          (let ((arg1 (code-run (^ 1))))
            (##reduction-apply1 $code rte proc arg1)))))))

(define ##cprc-app2-red
  (mk-cprc
    (let ((proc (code-run (^ 0))))
      (touch-vars (proc)
        (if (##not (##procedure? proc))
          (rt-error-non-procedure-oper $code rte)
          (let ((arg1 (code-run (^ 1)))
                (arg2 (code-run (^ 2))))
            (##reduction-apply2 $code rte proc arg1 arg2)))))))

(define ##cprc-app3-red
  (mk-cprc
    (let ((proc (code-run (^ 0))))
      (touch-vars (proc)
        (if (##not (##procedure? proc))
          (rt-error-non-procedure-oper $code rte)
          (let ((arg1 (code-run (^ 1)))
                (arg2 (code-run (^ 2)))
                (arg3 (code-run (^ 3))))
            (##reduction-apply3 $code rte proc arg1 arg2 arg3)))))))

(define ##cprc-app-red
  (mk-cprc
    (let ((proc (code-run (^ 0))))
      (touch-vars (proc)
        (if (##not (##procedure? proc))
          (rt-error-non-procedure-oper $code rte)
          (let loop ((i (##fixnum.- (code-length $code) 1)) (args '()))
            (if (##fixnum.< 0 i)
              (loop (##fixnum.- i 1) (##cons (code-run (code-ref $code i)) args))
              (##reduction-apply $code rte proc args))))))))

(define ##cprc-app0-sub
  (mk-cprc
    (let ((proc (code-run (^ 0))))
      (touch-vars (proc)
        (if (##not (##procedure? proc))
          (rt-error-non-procedure-oper $code rte)
          (##subproblem-apply0 $code rte proc))))))

(define ##cprc-app1-sub
  (mk-cprc
    (let ((proc (code-run (^ 0))))
      (touch-vars (proc)
        (if (##not (##procedure? proc))
          (rt-error-non-procedure-oper $code rte)
          (let ((arg1 (code-run (^ 1))))
            (##subproblem-apply1 $code rte proc arg1)))))))

(define ##cprc-app2-sub
  (mk-cprc
    (let ((proc (code-run (^ 0))))
      (touch-vars (proc)
        (if (##not (##procedure? proc))
          (rt-error-non-procedure-oper $code rte)
          (let ((arg1 (code-run (^ 1)))
                (arg2 (code-run (^ 2))))
            (##subproblem-apply2 $code rte proc arg1 arg2)))))))

(define ##cprc-app3-sub
  (mk-cprc
    (let ((proc (code-run (^ 0))))
      (touch-vars (proc)
        (if (##not (##procedure? proc))
          (rt-error-non-procedure-oper $code rte)
          (let ((arg1 (code-run (^ 1)))
                (arg2 (code-run (^ 2)))
                (arg3 (code-run (^ 3))))
            (##subproblem-apply3 $code rte proc arg1 arg2 arg3)))))))

(define ##cprc-app-sub
  (mk-cprc
    (let ((proc (code-run (^ 0))))
      (touch-vars (proc)
        (if (##not (##procedure? proc))
          (rt-error-non-procedure-oper $code rte)
          (let loop ((i (##fixnum.- (code-length $code) 1)) (args '()))
            (if (##fixnum.< 0 i)
              (loop (##fixnum.- i 1) (##cons (code-run (code-ref $code i)) args))
              (##subproblem-apply $code rte proc args))))))))

(define ##gen-app
  (mk-gen (oper args)
    (case (##length args)
      ((0)  (mk-code    (if tail? ##cprc-app0-red ##cprc-app0-sub) (oper)))
      ((1)  (mk-code    (if tail? ##cprc-app1-red ##cprc-app1-sub) (oper (##car args))))
      ((2)  (mk-code    (if tail? ##cprc-app2-red ##cprc-app2-sub) (oper (##car args) (##cadr args))))
      ((3)  (mk-code    (if tail? ##cprc-app3-red ##cprc-app3-sub) (oper (##car args) (##cadr args) (##caddr args))))
      (else (##mk-code* (if tail? ##cprc-app-red  ##cprc-app-sub)  (##cons oper args) 0)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##reduction-apply0 $code rte proc)
  (##declare (intr-checks))
  (proc))

(define (##reduction-apply1 $code rte proc arg1)
  (##declare (intr-checks))
  (proc arg1))

(define (##reduction-apply2 $code rte proc arg1 arg2)
  (##declare (intr-checks))
  (proc arg1 arg2))

(define (##reduction-apply3 $code rte proc arg1 arg2 arg3)
  (##declare (intr-checks))
  (proc arg1 arg2 arg3))

(define (##reduction-apply $code rte proc args)
  (##declare (intr-checks))
  (##apply proc args))

(define (##subproblem-apply0 $code rte proc)
  (##declare (intr-checks))
  (let ((result (proc)))
    (let ((a $code) (b rte))
      result)))

(define (##subproblem-apply1 $code rte proc arg1)
  (##declare (intr-checks))
  (let ((result (proc arg1)))
    (let ((a $code) (b rte))
      result)))

(define (##subproblem-apply2 $code rte proc arg1 arg2)
  (##declare (intr-checks))
  (let ((result (proc arg1 arg2)))
    (let ((a $code) (b rte))
      result)))

(define (##subproblem-apply3 $code rte proc arg1 arg2 arg3)
  (##declare (intr-checks))
  (let ((result (proc arg1 arg2 arg3)))
    (let ((a $code) (b rte))
      result)))

(define (##subproblem-apply $code rte proc args)
  (##declare (intr-checks))
  (let ((result (##apply proc args)))
    (let ((a $code) (b rte))
      result)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-delay
  (mk-cprc
    (delay (code-run (^ 0)))))

(define ##gen-delay
  (mk-gen (val)
    (mk-code ##cprc-delay (val))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##cprc-future
  (mk-cprc
    (future (code-run (^ 0)))))

(define ##gen-future
  (mk-gen (val)
    (mk-code ##cprc-future (val))))

;------------------------------------------------------------------------------

; Access to compiler created structures for interpreter procedures and frames

(define ##int-proc-body-format-1
  (##list (##proc-closure-body (##cprc-prc0 #f #f))
          (##proc-closure-body (##cprc-prc1 #f #f))
          (##proc-closure-body (##cprc-prc2 #f #f))
          (##proc-closure-body (##cprc-prc3 #f #f))))

(define ##int-proc-body-format-2
  (##list (##proc-closure-body (##cprc-prc       #f #f))
          (##proc-closure-body (##cprc-prc-rest  #f #f))))

(define (##int-proc? x)
  (and (##procedure? x)
       (##proc-closure? x)
       (or (##memq (##proc-closure-body x) ##int-proc-body-format-1)
           (##memq (##proc-closure-body x) ##int-proc-body-format-2))))

(define (##int-proc-code x)
  (if (##memq (##proc-closure-body x) ##int-proc-body-format-1)
    (##proc-closure-ref x 0)
    (##proc-closure-ref x 2)))

(define (##int-proc-rte x)
  (if (##memq (##proc-closure-body x) ##int-proc-body-format-1)
    (##proc-closure-ref x 2)
    (##proc-closure-ref x 1)))

;==============================================================================

; Eval

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Evaluation in the global environment (with current dynamic env)

(define ##eval-global #f)
(set! ##eval-global
  (lambda (expr)
    (##eval expr #f #f (##dynamic-env-ref))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Evaluation in a particular environment ('frames' describes the runtime
; environment 'rte').

(define ##eval #f)
(set! ##eval
  (lambda (expr frames rte dyn-env)
    (let ((c (##compile expr frames)))
      (##dynamic-env-bind
        dyn-env
        (lambda () (let ((rte rte)) (code-run c)))))))

;==============================================================================

; Decompilation of a piece of code

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(##define-macro (mk-degen params . def)
  `(lambda ($code ,@params) ,@def))

(##define-macro (degen proc . args)
  `(,proc $code ,@args))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##extract-frame subcode up)
  (let (($code (code-link subcode)))
    (if $code
      (let ((cprc (code-cprc $code)))
        (cond ((##eq? cprc ##cprc-top)
               (##extract-frame-top $code subcode up))
              ((##eq? cprc ##cprc-glo-def)
               (##extract-frame-glo-def $code subcode up))
              ((##eq? cprc ##cprc-case)
               (##extract-frame-case $code subcode up))
              ((##eq? cprc ##cprc-let)
               (##extract-frame-let $code subcode up))
              ((##eq? cprc ##cprc-letrec)
               (##extract-frame-letrec $code subcode up))
              ((or (##eq? cprc ##cprc-prc0)
                   (##eq? cprc ##cprc-prc1)
                   (##eq? cprc ##cprc-prc2)
                   (##eq? cprc ##cprc-prc3)
                   (##eq? cprc ##cprc-prc)
                   (##eq? cprc ##cprc-prc-rest))
               (##extract-frame-prc $code subcode up))
              (else
               (##extract-frame-default $code subcode up))))
      #f)))

(define ##extract-frame-default
  (lambda ($code subcode up)
    (##extract-frame $code up)))

(define ##extract-frame-top
  (lambda ($code subcode up)
    (if (##fixnum.= up 0)
      (##list (self-var))
      (let loop ((frames (^ 1)) (up (##fixnum.- up 1)))
        (if frames
          (if (##fixnum.= up 0)
            (##car frames)
            (loop (##cdr frames) (##fixnum.- up 1)))
          #f)))))

(define ##extract-frame-glo-def
  (lambda ($code subcode up)
    #f))

(define ##extract-frame-case
  (lambda ($code subcode up)
    (if (##eq? subcode (^ 1))
      (if (##fixnum.= up 0)
        (##list (selector-var))
        (##extract-frame $code (##fixnum.- up 1)))
      (##extract-frame $code up))))

(define ##extract-frame-let
  (lambda ($code subcode up)
    (if (##eq? subcode (^ 0))
      (if (##fixnum.= up 0)
        (code-ref $code (##fixnum.- (code-length $code) 1))
        (##extract-frame $code (##fixnum.- up 1)))
      (##extract-frame $code up))))

(define ##extract-frame-letrec
  (lambda ($code subcode up)
    (if (##fixnum.= up 0)
      (code-ref $code (##fixnum.- (code-length $code) 1))
      (##extract-frame $code (##fixnum.- up 1)))))

(define ##extract-frame-prc
  (lambda ($code subcode up)
    (if (##fixnum.= up 0)
      (##cons (self-var) (code-ref $code (##fixnum.- (code-length $code) 1)))
      (##extract-frame $code (##fixnum.- up 1)))))

(define (##extract-frames $code)

  (define (rev l tail)
    (if (##pair? l) (rev (##cdr l) (##cons (##car l) tail)) tail))

  (let loop ((i 0) (frames '()))
    (let ((frame (##extract-frame $code i)))
      (if frame
        (loop (##fixnum.+ i 1) (##cons frame frames))
        (rev frames #f)))))

(define (##extract-proc $code rte)
  (let loop ((i 0) (rte rte))
    (let ((frame (##extract-frame $code i)))
      (if frame
        (if (and (##pair? frame) (##eq? (##car frame) (self-var)))
          (rte-ref rte 1)
          (loop (##fixnum.+ i 1) (rte-up rte)))
        #f))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##BEGIN? x) (and (##pair? x) (##eq? (##car x) 'BEGIN)))
(define (##COND? x)  (and (##pair? x) (##eq? (##car x) 'COND)))
(define (##AND? x)   (and (##pair? x) (##eq? (##car x) 'AND)))
(define (##OR? x)    (and (##pair? x) (##eq? (##car x) 'OR)))
(define (##unspecified-obj? x)
  (and (##pair? x) (##eq? (##car x) 'QUOTE) (##eq? (##cadr x) (unspecified-obj))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define ##degen-top
  (mk-degen ()
    (##decomp (^ 0))))

(define ##degen-cst-x
  (mk-degen (val)
    (if (##self-eval? val) val (##list 'QUOTE val))))

(define ##degen-cst
  (mk-degen ()
    (degen ##degen-cst-x (^ 0))))

(define ##degen-loc-ref-x-y
  (mk-degen (up over)
    (degen ##degen-up-over up over)))

(define ##degen-up-over
  (mk-degen (up over)
    (let loop ((l (##extract-frame $code up)) (i over))
      (if (##fixnum.< i 2)
        (##car l)
        (loop (##cdr l) (##fixnum.- i 1))))))

(define ##degen-loc-ref
  (mk-degen ()
    (degen ##degen-loc-ref-x-y (^ 0) (^ 1))))

(define ##degen-glo-ref
  (mk-degen ()
    (global-env-loc->var (^ 0))))

(define ##degen-loc-set
  (mk-degen ()
    (##list 'SET! (degen ##degen-up-over (^ 1) (^ 2))
                  (##decomp (^ 0)))))

(define ##degen-glo-set
  (mk-degen ()
    (##list 'SET! (global-env-loc->var (^ 1))
                  (##decomp (^ 0)))))

(define ##degen-glo-def
  (mk-degen ()
    (##list 'DEFINE (global-env-loc->var (^ 1))
                    (##decomp (^ 0)))))

(define ##degen-if2
  (mk-degen ()
    (##list 'IF (##decomp (^ 0))
                (##decomp (^ 1)))))

(define ##degen-if3
  (mk-degen ()
    (##list 'IF (##decomp (^ 0))
                (##decomp (^ 1))
                (##decomp (^ 2)))))

(define ##degen-seq
  (mk-degen ()
    (let ((val1 (##decomp (^ 0)))
          (val2 (##decomp (^ 1))))
      (if (##BEGIN? val2)
        (##cons 'BEGIN (##cons val1 (##cdr val2)))
        (##list 'BEGIN val1 val2)))))

(define ##degen-quasi-list->vector
  (mk-degen ()
    (##list 'QUASIQUOTE (##make-vector 1 (##list 'UNQUOTE-SPLICING (##decomp (^ 0)))))))

(define ##degen-quasi-append
  (mk-degen ()
    (##list 'QUASIQUOTE (##list (##list 'UNQUOTE-SPLICING (##decomp (^ 0)))
                                (##list 'UNQUOTE-SPLICING (##decomp (^ 1)))))))

(define ##degen-quasi-cons
  (mk-degen ()
    (##list 'QUASIQUOTE (##list (##list 'UNQUOTE (##decomp (^ 0)))
                                (##list 'UNQUOTE-SPLICING (##decomp (^ 1)))))))

(define ##degen-cond-if
  (mk-degen ()
    (let ((val1 (##decomp (^ 0)))
          (val2 (##decomp (^ 1)))
          (val3 (##decomp (^ 2))))
      (##build-cond
        (if (##BEGIN? val2) (##cons val1 (##cdr val2)) (##list val1 val2))
        val3))))

(define ##degen-cond-or
  (mk-degen ()
    (let ((val1 (##decomp (^ 0)))
          (val2 (##decomp (^ 1))))
      (##build-cond (##list val1) val2))))

(define ##degen-cond-send
  (mk-degen ()
    (let ((val1 (##decomp (^ 0)))
          (val2 (##decomp (^ 1)))
          (val3 (##decomp (^ 2))))
      (##build-cond (##list val1 '=> val2) val3))))

(define (##build-cond clause rest)
  (cond ((##COND? rest)
         (##cons 'COND (##cons clause (##cdr rest))))
        ((##BEGIN? rest)
         (##cons 'COND (##list clause (##cons 'ELSE (##cdr rest)))))
        ((##unspecified-obj? rest)
         (##list 'COND clause))
        (else
         (##list 'COND clause (##list 'ELSE rest)))))

(define ##degen-or
  (mk-degen ()
    (let ((val1 (##decomp (^ 0)))
          (val2 (##decomp (^ 1))))
      (if (##OR? val2)
        (##cons 'OR (##cons val1 (##cdr val2)))
        (##list 'OR val1 val2)))))

(define ##degen-and
  (mk-degen ()
    (let ((val1 (##decomp (^ 0)))
          (val2 (##decomp (^ 1))))
      (if (##AND? val2)
        (##cons 'AND (##cons val1 (##cdr val2)))
        (##list 'AND val1 val2)))))

(define ##degen-case
  (mk-degen ()
    (let ((val1 (##decomp (^ 0)))
          (val2 (##decomp (^ 1))))
      (##cons 'CASE (##cons val1 val2)))))

(define ##degen-case-clause
  (mk-degen ()
    (let ((val1 (##decomp (^ 0)))
          (val2 (##decomp (^ 1))))
      (##cons (if (##BEGIN? val1)
                (##cons (^ 2) (##cdr val1))
                (##list (^ 2) val1))
              val2))))

(define ##degen-case-else
  (mk-degen ()
    (let ((val (##decomp (^ 0))))
      (if (##unspecified-obj? val)
        '()
        (##list (if (##BEGIN? val)
                  (##cons 'ELSE (##cdr val))
                  (##list 'ELSE val)))))))

(define ##degen-let
  (mk-degen ()
    (let ((n (code-length $code)))
      (let loop ((i (##fixnum.- n 2)) (vals '()))
        (if (##fixnum.< 0 i)
          (loop (##fixnum.- i 1)
                (##cons (##decomp (code-ref $code i)) vals))
          (let ((body (##decomp (^ 0)))
                (bindings (##make-bindings (code-ref $code (##fixnum.- n 1)) vals)))
            (if (##BEGIN? body)
              (##cons 'LET (##cons bindings (##cdr body)))
              (##list 'LET bindings body))))))))

(define (##make-bindings l1 l2)
  (if (##pair? l1)
    (##cons (##list (##car l1) (##car l2))
            (##make-bindings (##cdr l1) (##cdr l2)))
    '()))

(define ##degen-letrec
  (mk-degen ()
    (let ((n (code-length $code)))
      (let loop ((i (##fixnum.- n 2)) (vals '()))
        (if (##fixnum.< 0 i)
          (loop (##fixnum.- i 1)
                (##cons (##decomp (code-ref $code i)) vals))
          (let ((body (##decomp (^ 0)))
                (bindings (##make-bindings (code-ref $code (##fixnum.- n 1)) vals)))
            (if (##BEGIN? body)
              (##cons 'LETREC (##cons bindings (##cdr body)))
              (##list 'LETREC bindings body))))))))

(define ##degen-prc
  (mk-degen ()
    (let ((body (##decomp (^ 0)))
          (params (code-ref $code (##fixnum.- (code-length $code) 1))))
      (if (##BEGIN? body)
        (##cons 'LAMBDA (##cons params (##cdr body)))
        (##list 'LAMBDA params body)))))

(define ##degen-prc-rest
  (mk-degen ()
    (let ((body (##decomp (^ 0)))
          (params (##make-rest-params (^ 2))))
      (if (##BEGIN? body)
        (##cons 'LAMBDA (##cons params (##cdr body)))
        (##list 'LAMBDA params body)))))

(define (##make-rest-params l)
  (if (##null? (##cdr l))
    (##car l)
    (##cons (##car l) (##make-rest-params (##cdr l)))))

(define ##degen-app0
  (mk-degen ()
    (##list (##decomp (^ 0)))))

(define ##degen-app1
  (mk-degen ()
    (##list (##decomp (^ 0))
            (##decomp (^ 1)))))

(define ##degen-app2
  (mk-degen ()
    (##list (##decomp (^ 0))
            (##decomp (^ 1))
            (##decomp (^ 2)))))

(define ##degen-app3
  (mk-degen ()
    (##list (##decomp (^ 0))
            (##decomp (^ 1))
            (##decomp (^ 2))
            (##decomp (^ 3)))))

(define ##degen-app
  (mk-degen ()
    (let ((n (code-length $code)))
      (let loop ((i (##fixnum.- n 1)) (vals '()))
        (if (##not (##fixnum.< i 0))
          (loop (##fixnum.- i 1)
                (##cons (##decomp (code-ref $code i)) vals))
          vals)))))

(define ##degen-delay
  (mk-degen ()
    (##list 'DELAY (##decomp (^ 0)))))

(define ##degen-future
  (mk-degen ()
    (##list 'FUTURE (##decomp (^ 0)))))

;------------------------------------------------------------------------------

(define ##decomp-dispatch-table
  (##list
    (##cons ##cprc-top           ##degen-top)

    (##cons ##cprc-cst-null      (mk-degen () (degen ##degen-cst-x '())))
    (##cons ##cprc-cst-true      (mk-degen () (degen ##degen-cst-x #t)))
    (##cons ##cprc-cst-false     (mk-degen () (degen ##degen-cst-x #f)))
    (##cons ##cprc-cst--2        (mk-degen () (degen ##degen-cst-x -2)))
    (##cons ##cprc-cst--1        (mk-degen () (degen ##degen-cst-x -1)))
    (##cons ##cprc-cst-0         (mk-degen () (degen ##degen-cst-x 0)))
    (##cons ##cprc-cst-1         (mk-degen () (degen ##degen-cst-x 1)))
    (##cons ##cprc-cst-2         (mk-degen () (degen ##degen-cst-x 2)))
    (##cons ##cprc-cst           ##degen-cst)

    (##cons ##cprc-loc-ref-0-1   (mk-degen () (degen ##degen-loc-ref-x-y 0 1)))
    (##cons ##cprc-loc-ref-0-2   (mk-degen () (degen ##degen-loc-ref-x-y 0 2)))
    (##cons ##cprc-loc-ref-0-3   (mk-degen () (degen ##degen-loc-ref-x-y 0 3)))
    (##cons ##cprc-loc-ref-1-1   (mk-degen () (degen ##degen-loc-ref-x-y 1 1)))
    (##cons ##cprc-loc-ref-1-2   (mk-degen () (degen ##degen-loc-ref-x-y 1 2)))
    (##cons ##cprc-loc-ref-1-3   (mk-degen () (degen ##degen-loc-ref-x-y 1 3)))
    (##cons ##cprc-loc-ref-2-1   (mk-degen () (degen ##degen-loc-ref-x-y 2 1)))
    (##cons ##cprc-loc-ref-2-2   (mk-degen () (degen ##degen-loc-ref-x-y 2 2)))
    (##cons ##cprc-loc-ref-2-3   (mk-degen () (degen ##degen-loc-ref-x-y 2 3)))
    (##cons ##cprc-loc-ref       ##degen-loc-ref)
    (##cons ##cprc-glo-ref       ##degen-glo-ref)

    (##cons ##cprc-loc-set       ##degen-loc-set)
    (##cons ##cprc-glo-set       ##degen-glo-set)
    (##cons ##cprc-glo-def       ##degen-glo-def)

    (##cons ##cprc-if2           ##degen-if2)
    (##cons ##cprc-if3           ##degen-if3)
    (##cons ##cprc-seq           ##degen-seq)
    (##cons ##cprc-quasi-list->vector ##degen-quasi-list->vector)
    (##cons ##cprc-quasi-append  ##degen-quasi-append)
    (##cons ##cprc-quasi-cons    ##degen-quasi-cons)
    (##cons ##cprc-cond-if       ##degen-cond-if)
    (##cons ##cprc-cond-or       ##degen-cond-or)
    (##cons ##cprc-cond-send-red ##degen-cond-send)
    (##cons ##cprc-cond-send-sub ##degen-cond-send)

    (##cons ##cprc-or            ##degen-or)
    (##cons ##cprc-and           ##degen-and)

    (##cons ##cprc-case          ##degen-case)
    (##cons ##cprc-case-clause   ##degen-case-clause)
    (##cons ##cprc-case-else     ##degen-case-else)

    (##cons ##cprc-let           ##degen-let)
    (##cons ##cprc-letrec        ##degen-letrec)

    (##cons ##cprc-prc0          ##degen-prc)
    (##cons ##cprc-prc1          ##degen-prc)
    (##cons ##cprc-prc2          ##degen-prc)
    (##cons ##cprc-prc3          ##degen-prc)
    (##cons ##cprc-prc           ##degen-prc)
    (##cons ##cprc-prc-rest      ##degen-prc-rest)

    (##cons ##cprc-app0-red      ##degen-app0)
    (##cons ##cprc-app1-red      ##degen-app1)
    (##cons ##cprc-app2-red      ##degen-app2)
    (##cons ##cprc-app3-red      ##degen-app3)
    (##cons ##cprc-app-red       ##degen-app)
    (##cons ##cprc-app0-sub      ##degen-app0)
    (##cons ##cprc-app1-sub      ##degen-app1)
    (##cons ##cprc-app2-sub      ##degen-app2)
    (##cons ##cprc-app3-sub      ##degen-app3)
    (##cons ##cprc-app-sub       ##degen-app)

    (##cons ##cprc-delay         ##degen-delay)
    (##cons ##cprc-future        ##degen-future)
))

;------------------------------------------------------------------------------

(define (##decomp $code)
  (let ((cprc (code-cprc $code)))
    (let ((x (##assq cprc ##decomp-dispatch-table)))
      (if x
        (degen (##cdr x))
        '?))))

(define (##decompile proc)

  (define (decomp1 p)
    (if (##proc-subproc? p)
      (decomp2 (##proc-subproc-parent p) (##proc-subproc-tag p))
      (decomp2 p 0)))

  (define (decomp2 parent tag)
    (let ((info (##proc-debug-info parent)))
      (if info
        (let ((v (##vector-ref info 0)))
          (let loop ((i (##fixnum.- (##vector-length v) 1)))
            (if (##fixnum.< i 0)
              proc
              (let ((x (##vector-ref v i)))
                (if (##fixnum.= tag (##vector-ref x 0))
                  (source->expression (##vector-ref x 1))
                  (loop (##fixnum.- i 1)))))))
        proc)))

  (define (source-code x)
    (##vector-ref x 0))

  (define (source->expression source)

    (define (list->expression l)
      (cond ((##pair? l)
             (##cons (source->expression (##car l))
                     (list->expression (##cdr l))))
            ((##null? l)
             '())
            (else
             (source->expression l))))

    (define (vector->expression v)
      (let* ((len (##vector-length v))
             (x (##make-vector len #f)))
        (let loop ((i (##fixnum.- len 1)))
          (if (##not (##fixnum.< i 0))
            (begin
              (##vector-set! x i (source->expression (##vector-ref v i)))
              (loop (##fixnum.- i 1)))))
        x))

    (let ((code (source-code source)))
      (cond ((##pair? code)   (list->expression code))
            ((##vector? code) (vector->expression code))
            (else             code))))

  (cond ((##int-proc? proc)
         (##decomp (##int-proc-code proc)))
        ((##proc-closure? proc)
         (decomp1 (##proc-closure-body proc)))
        (else
         (decomp1 proc))))

;==============================================================================

; Debugger

;------------------------------------------------------------------------------

; Access to interpreter continuation frames

(define (##int-frame-non-subproblem? f)
  (let ((parent (##proc-subproc-parent (##frame-ret f))))
    (##assq parent ##decomp-dispatch-table)))

(define (##int-frame-subproblem? f)
  (let ((parent (##proc-subproc-parent (##frame-ret f))))
    (or (##eq? parent ##subproblem-apply0)
        (##eq? parent ##subproblem-apply1)
        (##eq? parent ##subproblem-apply2)
        (##eq? parent ##subproblem-apply3)
        (##eq? parent ##subproblem-apply))))

(define (##int-frame-subproblem-code f)
  (let ((parent (##proc-subproc-parent (##frame-ret f))))
    (if (##eq? parent ##subproblem-apply0)
      (##frame-stk-ref f 2)
      (##frame-stk-ref f 1))))

(define (##int-frame-subproblem-rte f)
  (let ((parent (##proc-subproc-parent (##frame-ret f))))
    (if (or (##eq? parent ##subproblem-apply2)
            (##eq? parent ##subproblem-apply3))
      (##frame-stk-ref f 2)
      (##frame-stk-ref f 3))))

;------------------------------------------------------------------------------

; Utilities

(define (##continuation->subproblems cont)
  (let loop ((f (##continuation->frame cont)) (l '()))
    (if f
      (if (##int-frame-non-subproblem? f)
        (loop (##frame-next f) l)
        (loop (##frame-next f) (##cons f l)))
      (##reverse l))))

(define (##eval-within expr f dyn-bindings)
  (let ((dyn-env (##cons dyn-bindings (##frame-dyn-env f))))
    (if (##int-frame-subproblem? f)
      (##eval expr
              (##extract-frames (##int-frame-subproblem-code f))
              (##int-frame-subproblem-rte f)
              dyn-env)
      (##eval expr #f #f dyn-env))))

(define (##procedure-name p)
  (or (##object->global-var-name p) p))

;------------------------------------------------------------------------------

; Read eval print loop

(define (##repl (in ##stdin) (out ##stdout) (prompt2 ": ") (prompt1 ""))
  (##call-with-current-continuation
    (lambda (cont) (##read-eval-print in out prompt2 prompt1 cont))))

(define ##repl-write #f)
(set! ##repl-write #f)

(define ##repl-read #f)
(set! ##repl-read #f)

(define (##read-eval-print in out prompt2 prompt1 cont)

  (define (repl-start subprobs repl-info dyn-bindings)

    (define (repl-read)
      (let ((proc ##repl-read))
        (if (##procedure? proc)
          (proc in)
          (##read in))))

    (define (repl-write val)
      (let ((proc ##repl-write))
        (if (##procedure? proc)
          (proc val out)
          (begin
            (##write val out (if-touches #t #f))
            (##newline out)))))

    (define (repl-n n)
      (let loop ((i 0) (s subprobs))
        (if (and (##fixnum.< n i) (##pair? (##cdr s)))
          (loop (##fixnum.- i 1) (##cdr s))
          (let ((f (##car s)))
            (##display-subproblem i f out)
            (repl i s f)))))

    (define (cmd-d)
      (let ((l (##cdr (##vector-ref repl-info 3))))
        (if (##pair? l)
          ((##car l) #f)
          (begin
            (##newline out)
            (##write-string "*** ^D again to exit" out)
            (##newline out)
            (if (##eof-object? (##peek-char in))
              (##quit))))))

    (define (cmd-t)
      (let loop ((l (##vector-ref repl-info 3)))
        (if (##pair? (##cdr l))
          (loop (##cdr l))
          ((##car l) #f))))

    (define (repl pos subprobs* f)

      (##call-with-current-continuation
        (lambda (abort)
          (##set-car! (##vector-ref repl-info 3) abort)))

      (let loop ()

        (##newline out)
        (##display prompt1 out #f)
        (if (##fixnum.< pos 0) (##display pos out #f))
        (##display prompt2 out #f)

        (let ((expr (repl-read)))
          (if (##eof-object? expr)
            (begin (cmd-d) (loop))
            (if (and (##pair? expr)
                     (##pair? (##cdr expr))
                     (##null? (##cddr expr))
                     (##eq? (##car expr) 'UNQUOTE))
              (let ((cmd (##cadr expr)))
                (if (##eof-object? cmd)
                  (begin (cmd-d) (loop))
                  (case cmd
                    ((?) (##cmd-? out) (loop))
                    ((-) (repl-n (##fixnum.- pos 1)))
                    ((+) (repl-n (##fixnum.+ pos 1)))
                    ((b) (##cmd-b pos subprobs* out) (loop))
                    ((i) (##cmd-i f out) (loop))
                    ((y) (##cmd-y f out) (loop))
                    ((l) (##cmd-l f out) (loop))
                    ((t) (cmd-t))
                    ((d) (cmd-d) (loop))
                    ((r) (##display "Return value: " out #f)
                         (let ((expr (repl-read)))
                           (if (##eof-object? expr)
                             ##undef-object
                             (##eval-within expr f dyn-bindings))))
                    ((q) (##quit))
                    (else
                     (if (and (##fixnum? cmd) (##fixnum.< cmd 1))
                       (repl-n cmd)
                       (begin
                         (##write-string "Unknown command ," out)
                         (##write cmd out #f)
                         (##newline out)
                         (loop)))))))
            (let ((val (##eval-within expr f dyn-bindings)))
              (repl-write val)
              (loop)))))))

    (repl 0 subprobs (##car subprobs)))

  (let ((repl-info (##make-vector 4 #f)))
    (let ((prev-info (##dynamic-ref '##REPL-INFO #f))
          (dyn-bindings (##list (##cons '##REPL-INFO repl-info))))
      (##vector-set! repl-info 0 in)
      (##vector-set! repl-info 1 out)
      (##vector-set! repl-info 2
        (if prev-info
          (##fixnum.+ (##vector-ref prev-info 2) 1)
          0))
      (##vector-set! repl-info 3
        (##cons (lambda (x) (##quit))
                (if prev-info
                  (##vector-ref prev-info 3)
                  '())))
      (##dynamic-bind
        dyn-bindings
        (lambda ()
          (repl-start (##continuation->subproblems cont)
                      repl-info
                      dyn-bindings))))))

(define (##repl-out)
  (let ((repl-info (##dynamic-ref '##REPL-INFO #f)))
    (if repl-info
      (##vector-ref repl-info 1)
      ##stdout)))

(define (##debug-repl cont)
  (let ((repl-info (##dynamic-ref '##REPL-INFO #f)))
    (if repl-info
      (##read-eval-print (##vector-ref repl-info 0)
                         (##vector-ref repl-info 1)
                         ": "
                         (##fixnum.+ (##vector-ref repl-info 2) 1)
                         cont)
      (##read-eval-print ##stdin ##stdout ": " 0 cont))))

(define (##pop-repl)
  (let ((repl-info (##dynamic-ref '##REPL-INFO #f)))
    (if repl-info
      ((##car (##vector-ref repl-info 3)) #f)
      (##quit))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##cmd-? out)
  (##write-string ",?        : Summary of commands" out) (##newline out)
  (##write-string ",+ and ,- : Move to next or previous frame of continuation" out) (##newline out)
  (##write-string ",<n>      : Move to particular frame (<n> <= 0)" out) (##newline out)
  (##write-string ",b        : Display frames of continuation (i.e. backtrace)" out) (##newline out)
  (##write-string ",i        : Display procedure attached to current frame" out) (##newline out)
  (##write-string ",y        : Display subproblem of current frame" out) (##newline out)
  (##write-string ",l        : Display list of local variables accessible in current frame" out) (##newline out)
  (##write-string ",t        : Transfer to top-level REP loop" out) (##newline out)
  (##write-string ",d        : Transfer to previous REP loop" out) (##newline out)
  (##write-string ",r        : Return from REP loop" out) (##newline out)
  (##write-string ",q        : Quit" out) (##newline out))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##cmd-b pos subprobs* out)
  (define max-head 10)
  (define max-tail 6)
  (let loop ((i 0) (j (##fixnum.- (##length subprobs*) 1)) (l subprobs*))
    (if (##pair? l)
      (begin
        (cond ((or (##fixnum.< i max-head) (##fixnum.< j max-tail)
                   (and (##fixnum.= i max-head) (##fixnum.= j max-tail)))
               (##display-subproblem (##fixnum.- pos i) (##car l) out))
              ((##fixnum.= i max-head)
               (##write-string "..." out) (##newline out)))
        (loop (##fixnum.+ i 1) (##fixnum.- j 1) (##cdr l))))))

(define (##display-subproblem pos f out)
  (let ((x (##write pos out #f)))
    (##display-spaces (##fixnum.- 4 x) out)
    (##write-string " " out)

    (if (##int-frame-subproblem? f)

      (let ((code (##int-frame-subproblem-code f))
            (rte (##int-frame-subproblem-rte f)))
        (let ((proc (##extract-proc code rte)))
          (let ((x (if proc
                     (##write (##procedure-name proc) out #f)
                     (##display "(top level)" out #f))))
            (##display-spaces (##fixnum.- 25 x) out)
            (##write-string " " out)
            (##write-string (##object->string (##decomp code) 48 #f) out)
            (##newline out))))

      (let ((parent (##proc-subproc-parent (##frame-ret f))))
        (let ((x (##write (##procedure-name parent) out #f)))
          (let ((y (##decompile (##frame-ret f))))
            (if (##not (##eq? y (##frame-ret f)))
              (begin
                (##display-spaces (##fixnum.- 25 x) out)
                (##write-string " " out)
                (##write-string (##object->string y 48 #f) out)))
            (##newline out)))))))

(define (##display-spaces n out)
  (if (##fixnum.< 0 n)
    (let ((m (if (##fixnum.< 40 n) 40 n)))
      (##write-substring "                                        " 0 m out)
      (##display-spaces (##fixnum.- n m) out))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##cmd-l f out)

  (define (display-locals frames rte)
    (let loop1 ((l frames) (r rte))
      (if (##pair? l)
        (let loop2 ((frame (##car l)) (values (##cdr (##vector->list r))))
          (if (##pair? frame)
            (let ((var (##car frame)))
              (if (##not (or (##eq? var (self-var))
                             (##eq? var (selector-var))
                             (##eq? var (do-loop-var))))
                (let ((x (##write var out #f)))
                  (##write-string " = " out)
                  (##write-string (##object->string
                                    (##car values)
                                    (##fixnum.- (##fixnum.- (##port-width out) 3) x)
                                    (if-touches #t #f))
                                  out)
                  (##newline out)))
              (loop2 (##cdr frame) (##cdr values)))
            (loop1 (##cdr l) (rte-up r)))))))

  (if (##int-frame-subproblem? f)
    (display-locals (##extract-frames (##int-frame-subproblem-code f))
                    (##int-frame-subproblem-rte f))
    (begin
      (##write-string "Sorry, can't display compiled code environment" out)
      (##newline out))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##cmd-y f out)
  (if (##int-frame-subproblem? f)
    (##pretty-print (##decomp (##int-frame-subproblem-code f)) out (##port-width out))
    (let ((x (##decompile (##frame-ret f))))
      (if (##eq? x (##frame-ret f))
        (begin
          (##write-string "Sorry, this code was compiled without the DEBUG option" out)
          (##newline out))
        (##pretty-print x out (##port-width out))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##cmd-i f out)
  (if (##int-frame-subproblem? f)

    (let ((code (##int-frame-subproblem-code f))
          (rte (##int-frame-subproblem-rte f)))
      (let ((proc (##extract-proc code rte)))
        (if proc
          (begin
            (##write proc out #f)
            (##write-string " =" out)
            (##newline out)
            (##pretty-print (##decompile proc) out (##port-width out)))
          (begin
            (##write-string "(top level)" out)
            (##newline out)))))

    (let ((proc (##proc-subproc-parent (##frame-ret f))))
      (##write proc out #f)
      (let ((x (##decompile proc)))
        (if (##eq? x proc)
          (##newline out)
          (begin
            (##write-string " =" out)
            (##newline out)
            (##pretty-print x out (##port-width out))))))))

;==============================================================================